home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / numio.scm < prev    next >
Text File  |  1995-10-13  |  5KB  |  176 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ;;;; number->string and string->number
  4.  
  5. ; NUMBER->STRING
  6.  
  7. (define-generic number->string &number->string)
  8.  
  9. (define-method &number->string (n)
  10.   (number->string n 10))
  11.  
  12. (define-method &number->string (n radix)
  13.   "#{Number}")    ;Shouldn't happen
  14.  
  15. (define-method &number->string ((n :exact-integer) radix)
  16.   (integer->string n radix))
  17.  
  18. (define integer->string    ;Won't necessarily work if n is inexact
  19.   (let ()
  20.  
  21.     (define (integer->string n radix)
  22.       (let ((magnitude
  23.          (if (= n 0)
  24.          (list #\0)
  25.          (let recur ((n n) (l '()))
  26.            (if (= n 0)
  27.                l
  28.                (recur (quotient n radix)
  29.                   (cons (integer->digit (abs (remainder n radix)))
  30.                     l)))))))
  31.     (list->string (if (>= n 0)
  32.               magnitude
  33.               (cons #\- magnitude)))))
  34.  
  35.     (define (integer->digit n)
  36.       (ascii->char (+ n (if (< n 10)
  37.                 zero
  38.                 a-minus-10))))
  39.  
  40.     (define zero (char->ascii #\0))
  41.     (define a-minus-10 (- (char->ascii #\a) 10))
  42.  
  43.     integer->string))
  44.  
  45.  
  46. ; STRING->NUMBER
  47.  
  48. ; This just strips off any # prefixes and hands the rest off to
  49. ; really-string->number, which is generic.
  50.  
  51. (define (string->number string . options)
  52.   (let* ((radix (cond ((null? options) 10)
  53.               ((null? (cdr options)) (car options))
  54.               ;; Revised^3 Scheme compatibility
  55.               (else (cadr options))))
  56.      (radix (case radix
  57.           ((2 8 10 16) radix)
  58.           ((b) 2) ((o) 8) ((d) 10) ((x) 16)    ;R3RS only?
  59.           (else (call-error "invalid radix"
  60.                     'string->number
  61.                     string radix))))
  62.      (len (string-length string)))
  63.     (let loop ((pos 0) (exactness? #f) (exact? #t) (radix? #f) (radix radix))
  64.       (cond ((>= pos len)
  65.          #f)
  66.         ((char=? (string-ref string pos) #\#)
  67.          (let ((pos (+ pos 1)))
  68.            (if (>= pos len)
  69.            #f
  70.            (let ((radix-is
  71.               (lambda (radix)
  72.                 (if radix?
  73.                 #f
  74.                 (loop (+ pos 1) exactness? exact? #t radix))))
  75.              (exactness-is
  76.               (lambda (exact?)
  77.                 (if exactness?
  78.                 #f
  79.                 (loop (+ pos 1) #t exact? radix? radix)))))
  80.              (case (char-downcase (string-ref string pos))
  81.                ((#\b) (radix-is 2))
  82.                ((#\o) (radix-is 8))
  83.                ((#\d) (radix-is 10))
  84.                ((#\x) (radix-is 16))
  85.                ((#\e) (exactness-is #t))
  86.                ((#\i) (exactness-is #f))
  87.                (else #f))))))
  88.         (else
  89.          (really-string->number
  90.             (substring string pos len)
  91.         radix
  92.         (if exactness?
  93.             exact?
  94.             (let loop ((pos pos))
  95.               (cond ((>= pos len) #t) ;exact
  96.                 ((char=? (string-ref string pos) #\.)
  97.                  (if (not (= radix 10))
  98.                  (warn "non-base-10 number has decimal point"
  99.                        string))
  100.                  #f)    ;inexact
  101.                 ((char=? (string-ref string pos) #\#)
  102.                  #f)
  103.                 (else (loop (+ pos 1))))))))))))
  104.  
  105. (define-generic really-string->number &really-string->number)
  106.  
  107. (define-method &really-string->number (string radix xact?) #f)
  108.  
  109.  
  110. ; Read exact integers
  111.  
  112. (define-simple-type :integer-string (:string)
  113.   (lambda (s)
  114.     (and (string? s)
  115.      (let loop ((i (- (string-length s) 1)))
  116.        (if (< i 0)
  117.            #t
  118.            (let ((c (string-ref s i)))
  119.          (and (or (char-numeric? c)
  120.               (and (char>=? c #\a)
  121.                    (char<=? c #\f))
  122.               (and (char>=? c #\A)
  123.                    (char<=? c #\F))
  124.               (and (= i 0)
  125.                    (or (char=? c #\+) (or (char=? c #\-)))))
  126.               (loop (- i 1)))))))))
  127.  
  128. (define-method &really-string->number ((string :integer-string) radix xact?)
  129.   (let ((n (string->integer string radix)))
  130.     (if n (set-exactness n xact?) #f)))
  131.  
  132. (define (set-exactness n xact?)
  133.   (if (exact? n)
  134.       (if xact? n (exact->inexact n))
  135.       (if xact? (inexact->exact n) n)))
  136.  
  137. (define string->integer
  138.   (let ()
  139.  
  140.     (define (string->integer string radix)
  141.       (cond ((= (string-length string) 0) #f)
  142.         ((char=? (string-ref string 0) #\+)
  143.          (do-it string 1 1 radix))
  144.         ((char=? (string-ref string 0) #\-)
  145.          (do-it string 1 -1 radix))
  146.         (else
  147.          (do-it string 0 1 radix))))
  148.  
  149.     (define (do-it string pos sign radix)
  150.       (let* ((len (string-length string)))
  151.     (if (>= pos len)
  152.         #f
  153.         (let loop ((n 0) (pos pos))
  154.           (if (>= pos len)
  155.           n
  156.           (let ((d (digit->integer (string-ref string pos)
  157.                        radix)))
  158.             (if d
  159.             (loop (+ (* n radix) (* sign d))
  160.                   (+ pos 1))
  161.             #f)))))))
  162.  
  163.     (define (digit->integer c radix)
  164.       (cond ((char-numeric? c)
  165.          (let ((n (- (char->ascii c) zero)))
  166.            (if (< n radix) n #f)))
  167.         ((<= radix 10) #f)
  168.         (else
  169.          (let ((n (- (char->ascii (char-downcase c)) a-minus-ten)))
  170.            (if (and (>= n 10) (< n radix)) n #f)))))
  171.     
  172.     (define zero (char->ascii #\0))
  173.     (define a-minus-ten (- (char->ascii #\a) 10))
  174.  
  175.     string->integer))
  176.